home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / funlink.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-25  |  27.0 KB  |  792 lines
  1. /*  Copyright William Schelter. All rights reserved.
  2. Fast linking method for kcl by W. Schelter University of Texas
  3.    Note there are also changes to 
  4.  cmpcall.lsp and cmptop.lsp */
  5.  
  6.  
  7. #include "include.h"
  8. #include "sfun_argd.h"
  9.  
  10.  
  11. object siLcdefn;
  12. typedef object (*object_func)();
  13.  
  14. object Vlink_array;
  15. int Rset = 0;
  16.  
  17. void
  18. call_or_link(sym,link)
  19. int *link;
  20. object sym;
  21. {object fun;
  22.  fun = sym->s.s_gfdef;
  23.  if (fun == OBJNULL) {FEinvalid_function(sym); return;}
  24.  if (type_of(fun) == t_cclosure
  25.      && (fun->cc.cc_turbo))
  26.    {if (Rset==0) {MMccall(fun, fun->cc.cc_turbo);}
  27.     else (*(fun)->cf.cf_self)(fun->cc.cc_turbo);
  28.     return;}
  29.  if (Rset==0) funcall(fun);
  30.    else
  31.    if (type_of(fun) == t_cfun)
  32.        { (void) vpush_extend((int) link,Vlink_array->s.s_dbind);
  33.       (void) vpush_extend((int) *link,Vlink_array->s.s_dbind);     
  34.          *link = (int) (fun->cf.cf_self);
  35.      (*(void (*)())(fun->cf.cf_self))();
  36.        }
  37.    else funcall(fun);}
  38.  
  39. void
  40. call_or_link_closure(sym,link,ptr)
  41. int *link;
  42. object sym;
  43. object *ptr;
  44. {object fun;
  45.  fun = sym->s.s_gfdef;
  46.  if (fun == OBJNULL) {FEinvalid_function(sym); return;}
  47.  if (type_of(fun) == t_cclosure
  48.      && (fun->cc.cc_turbo))
  49.    {if (Rset) {
  50.      (void) vpush_extend((int) link,Vlink_array->s.s_dbind);
  51.      (void) vpush_extend((int) *link,Vlink_array->s.s_dbind);
  52.      *ptr = (void *)(fun->cc.cc_turbo);
  53.      *link = (int) (fun->cf.cf_self);
  54.      MMccall(fun, fun->cc.cc_turbo);}
  55.     else
  56.       {MMccall(fun, fun->cc.cc_turbo);}
  57.     return;}
  58.  if (Rset==0) funcall(fun);
  59.    else
  60.      /* can't do this if invoking foo(a) is illegal when foo is not defined
  61.     to take any arguments.   In the majority of C's this is legal */
  62.      
  63.    if (type_of(fun) == t_cfun)
  64.        { (void) vpush_extend((int) link,Vlink_array->s.s_dbind);
  65.       (void) vpush_extend((int) *link,Vlink_array->s.s_dbind);     
  66.          *link = (int) (fun->cf.cf_self);
  67.      (*(void (*)())(fun->cf.cf_self))();
  68.        }
  69.    else funcall(fun);}
  70.  
  71. /* for pushing item into an array, where item is an address if array-type = t
  72. or a fixnum if array-type = fixnum */
  73.  
  74. vpush_extend(item,ar)
  75. int item; object ar;
  76. { register int ind = ar->v.v_fillp;
  77.   if (ind < ar->fixa.fixa_dim)
  78.    {ar->fixa.fixa_self[ind] = item;
  79.     return(ar->v.v_fillp = ++ind);}
  80.        else
  81.     { register int *oldp ;
  82.       int newdim=(2 + (int) (1.3 * ind));
  83.       char *newself;
  84.       newself=alloc_relblock(sizeof(int)*newdim);
  85.       oldp= ar->fixa.fixa_self;
  86.       ar->fixa.fixa_dim=newdim;
  87.       ar->fixa.fixa_self=(fixnum *)newself;
  88.       
  89.      /* this should be ok since the gc may be called at allocself, but when the
  90. actual allocation takes place, the array is still pointing to its old body,
  91. and the gc will not be called while we run through copying */
  92.      {register int *p = ar->fixa.fixa_self;
  93.       register int *last ;
  94.       last =  (p + ind);
  95.       while ( p < last)
  96.     *p++ = *oldp++;
  97.       *p=item;}
  98.       return(++(ar->v.v_fillp));
  99.     }
  100.   
  101.    }
  102.  
  103. /* if we unlink a bunch of functions, this will mean there are some
  104.    holes in the link array, and we should probably go through it and
  105.    push them back  */
  106. static int number_unlinked=0;
  107.  
  108. Luse_fast_links()
  109. {use_fast_links(vs_top-vs_base,vs_base[0],vs_top[-1]);}
  110.  
  111. delete_link(address,link_ar) 
  112.      int address;
  113.      object link_ar;
  114. {int *ar,*ar_end,*p;
  115.  p=0;
  116.  ar = link_ar->fixa.fixa_self;
  117.  ar_end = ar +   link_ar->v.v_fillp;
  118.  while (ar < ar_end)
  119.    { if (*ar && *((int *)*ar)==address)
  120.        { p = (int *) *ar;
  121.      *ar=0;
  122.      *p = *(ar+1);
  123.      number_unlinked++;}
  124.      ar=ar+2;}
  125.  if (number_unlinked > 40)
  126.    link_ar->v.v_fillp=
  127.      clean_link_array(link_ar->fixa.fixa_self,ar_end); }
  128.  
  129.  
  130. use_fast_links(n,flag,sym)
  131.      int n;
  132.      object sym,flag;
  133.      
  134. { register int  *ar,*ar_end;
  135.   int *p;
  136.   object link_ar;
  137.   object fun;
  138.  
  139.   link_ar = Vlink_array->s.s_dbind;
  140.   if (link_ar==Cnil && flag==Cnil) return 0;
  141.   check_type_array(&link_ar);
  142.   ar = link_ar->fixa.fixa_self;
  143.   ar_end = ar +   link_ar->v.v_fillp;
  144.     switch (n)
  145.       {
  146.   case 1:
  147.    if (flag==Cnil)
  148.     { Rset=0;
  149.      while ( ar < ar_end)
  150.       /* set the link variables back to initial state */
  151.      { 
  152.         p = (int *) *ar;
  153.         if (p) *p = (ar++, *ar); else ar++;
  154.        ar++;
  155.      }
  156.     link_ar->v.v_fillp = 0;
  157.     }
  158.   else
  159.     { Rset=1;}
  160.     break;
  161.   case 2:
  162.    if (!(type_of(sym)==t_symbol)) not_a_symbol(sym);
  163.    fun = sym->s.s_gfdef;
  164.    goto BEGIN;
  165.  case 3:
  166.    fun = sym;
  167.  BEGIN:
  168.    if(Rset)
  169.      {
  170.       if(!fun) return 0;
  171.       switch(type_of(fun)){
  172.       case t_cfun:
  173.       case t_sfun:
  174.       case t_vfun:    
  175.       case t_gfun:
  176.       case t_cclosure:
  177.     delete_link((int)fun->cf.cf_self,link_ar);
  178.     /* becoming obsolete 
  179.      y=getf(sym->s.s_plist,siLcdefn,Cnil);
  180.      if (y!=Cnil)
  181.        delete_link(fix(y),link_ar);
  182.        */
  183.  
  184.       break;
  185.     
  186.     }
  187.   }
  188.     break;
  189.   default:
  190.     FEerror("Usage: (use-fast-links {nil,t} &optional fun)",0);
  191.    return(0);
  192. }
  193. }
  194.  
  195.  
  196. clean_link_array(ar,ar_end)
  197. int *ar,*ar_end;
  198. {int i=0;
  199.  int *orig;
  200.  orig=ar;
  201.  number_unlinked=0;
  202.   while( ar<ar_end)
  203.    {if(*ar)
  204.       {orig[i++]= *ar++ ;
  205.      orig[i++]= *ar++;
  206.        }
  207.    else ar=ar+2;       
  208.     }
  209.  return(i);
  210.  }
  211.  
  212. #include <varargs.h>
  213.  
  214. object
  215. c_apply_n(fn,n,x)
  216.      object *x;
  217.      int n;
  218.      object (*fn)();
  219. {object res;
  220.  switch(n){
  221.     case 0:  res=(*fn)();break;
  222.     case 1:  res=(*fn)(x[0]);break;
  223.     case 2:  res=(*fn)(x[0],x[1]);break;
  224.     case 3:  res=(*fn)(x[0],x[1],x[2]);break;
  225.     case 4:  res=(*fn)(x[0],x[1],x[2],x[3]);break;
  226.     case 5:  res=(*fn)(x[0],x[1],x[2],x[3],x[4]);break;
  227.     case 6:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5]);break;
  228.     case 7:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6]);break;
  229.     case 8:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7]);break;
  230.     case 9:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  231.          x[8]);break;
  232.     case 10:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  233.          x[8],x[9]);break;
  234.     case 11:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  235.          x[8],x[9],x[10]);break;
  236.     case 12:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  237.          x[8],x[9],x[10],x[11]);break;
  238.     case 13:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  239.          x[8],x[9],x[10],x[11],x[12]);break;
  240.     case 14:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  241.          x[8],x[9],x[10],x[11],x[12],x[13]);break;
  242.     case 15:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  243.          x[8],x[9],x[10],x[11],x[12],x[13],x[14]);break;
  244.     case 16:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  245.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  246.          x[15]);break;
  247.     case 17:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  248.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  249.          x[15],x[16]);break;
  250.     case 18:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  251.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  252.          x[15],x[16],x[17]);break;
  253.     case 19:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  254.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  255.          x[15],x[16],x[17],x[18]);break;
  256.     case 20:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  257.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  258.          x[15],x[16],x[17],x[18],x[19]);break;
  259.     case 21:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  260.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  261.          x[15],x[16],x[17],x[18],x[19],x[20]);break;
  262.     case 22:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  263.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  264.          x[15],x[16],x[17],x[18],x[19],x[20],x[21]);break;
  265.     case 23:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  266.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  267.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  268.          x[22]);break;
  269.     case 24:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  270.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  271.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  272.          x[22],x[23]);break;
  273.     case 25:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  274.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  275.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  276.          x[22],x[23],x[24]);break;
  277.     case 26:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  278.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  279.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  280.          x[22],x[23],x[24],x[25]);break;
  281.     case 27:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  282.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  283.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  284.          x[22],x[23],x[24],x[25],x[26]);break;
  285.     case 28:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  286.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  287.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  288.          x[22],x[23],x[24],x[25],x[26],x[27]);break;
  289.     case 29:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  290.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  291.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  292.          x[22],x[23],x[24],x[25],x[26],x[27],x[28]);break;
  293.     case 30:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  294.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  295.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  296.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  297.          x[29]);break;
  298.     case 31:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  299.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  300.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  301.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  302.          x[29],x[30]);break;
  303.     case 32:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  304.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  305.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  306.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  307.          x[29],x[30],x[31]);break;
  308.     case 33:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  309.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  310.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  311.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  312.          x[29],x[30],x[31],x[32]);break;
  313.     case 34:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  314.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  315.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  316.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  317.          x[29],x[30],x[31],x[32],x[33]);break;
  318.     case 35:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  319.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  320.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  321.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  322.          x[29],x[30],x[31],x[32],x[33],x[34]);break;
  323.     case 36:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  324.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  325.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  326.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  327.          x[29],x[30],x[31],x[32],x[33],x[34],x[35]);break;
  328.     case 37:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  329.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  330.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  331.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  332.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  333.          x[36]);break;
  334.     case 38:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  335.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  336.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  337.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  338.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  339.          x[36],x[37]);break;
  340.     case 39:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  341.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  342.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  343.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  344.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  345.          x[36],x[37],x[38]);break;
  346.     case 40:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  347.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  348.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  349.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  350.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  351.          x[36],x[37],x[38],x[39]);break;
  352.     case 41:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  353.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  354.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  355.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  356.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  357.          x[36],x[37],x[38],x[39],x[40]);break;
  358.     case 42:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  359.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  360.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  361.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  362.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  363.          x[36],x[37],x[38],x[39],x[40],x[41]);break;
  364.     case 43:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  365.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  366.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  367.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  368.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  369.          x[36],x[37],x[38],x[39],x[40],x[41],x[42]);break;
  370.     case 44:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  371.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  372.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  373.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  374.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  375.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  376.          x[43]);break;
  377.     case 45:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  378.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  379.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  380.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  381.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  382.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  383.          x[43],x[44]);break;
  384.     case 46:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  385.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  386.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  387.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  388.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  389.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  390.          x[43],x[44],x[45]);break;
  391.     case 47:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  392.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  393.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  394.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  395.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  396.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  397.          x[43],x[44],x[45],x[46]);break;
  398.     case 48:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  399.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  400.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  401.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  402.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  403.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  404.          x[43],x[44],x[45],x[46],x[47]);break;
  405.     case 49:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  406.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  407.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  408.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  409.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  410.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  411.          x[43],x[44],x[45],x[46],x[47],x[48]);break;
  412.     case 50:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  413.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  414.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  415.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  416.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  417.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  418.          x[43],x[44],x[45],x[46],x[47],x[48],x[49]);break;
  419.     case 51:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  420.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  421.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  422.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  423.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  424.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  425.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  426.          x[50]);break;
  427.     case 52:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  428.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  429.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  430.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  431.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  432.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  433.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  434.          x[50],x[51]);break;
  435.     case 53:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  436.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  437.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  438.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  439.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  440.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  441.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  442.          x[50],x[51],x[52]);break;
  443.     case 54:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  444.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  445.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  446.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  447.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  448.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  449.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  450.          x[50],x[51],x[52],x[53]);break;
  451.     case 55:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  452.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  453.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  454.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  455.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  456.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  457.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  458.          x[50],x[51],x[52],x[53],x[54]);break;
  459.     case 56:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  460.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  461.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  462.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  463.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  464.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  465.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  466.          x[50],x[51],x[52],x[53],x[54],x[55]);break;
  467.     case 57:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  468.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  469.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  470.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  471.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  472.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  473.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  474.          x[50],x[51],x[52],x[53],x[54],x[55],x[56]);break;
  475.     case 58:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  476.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  477.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  478.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  479.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  480.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  481.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  482.          x[50],x[51],x[52],x[53],x[54],x[55],x[56],
  483.          x[57]);break;
  484.     case 59:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  485.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  486.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  487.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  488.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  489.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  490.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  491.          x[50],x[51],x[52],x[53],x[54],x[55],x[56],
  492.          x[57],x[58]);break;
  493.     case 60:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  494.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  495.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  496.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  497.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  498.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  499.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  500.          x[50],x[51],x[52],x[53],x[54],x[55],x[56],
  501.          x[57],x[58],x[59]);break;
  502.     case 61:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  503.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  504.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  505.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  506.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  507.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  508.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  509.          x[50],x[51],x[52],x[53],x[54],x[55],x[56],
  510.          x[57],x[58],x[59],x[60]);break;
  511.     case 62:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  512.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  513.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  514.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  515.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  516.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  517.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  518.          x[50],x[51],x[52],x[53],x[54],x[55],x[56],
  519.          x[57],x[58],x[59],x[60],x[61]);break;
  520.     case 63:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  521.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  522.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  523.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  524.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  525.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  526.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  527.          x[50],x[51],x[52],x[53],x[54],x[55],x[56],
  528.          x[57],x[58],x[59],x[60],x[61],x[62]);break;
  529.     case 64:  res=(*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
  530.          x[8],x[9],x[10],x[11],x[12],x[13],x[14],
  531.          x[15],x[16],x[17],x[18],x[19],x[20],x[21],
  532.          x[22],x[23],x[24],x[25],x[26],x[27],x[28],
  533.          x[29],x[30],x[31],x[32],x[33],x[34],x[35],
  534.          x[36],x[37],x[38],x[39],x[40],x[41],x[42],
  535.          x[43],x[44],x[45],x[46],x[47],x[48],x[49],
  536.          x[50],x[51],x[52],x[53],x[54],x[55],x[56],
  537.          x[57],x[58],x[59],x[60],x[61],x[62],x[63]);break;
  538.   default: FEerror("Exceeded call-arguments-limit ");
  539.   } 
  540.  
  541.  return res;
  542. }
  543.   
  544. /* Used for calling cfunctions which take object args, and return object 
  545. value.  This function is called by the static lnk function in the reference
  546. file */
  547.  
  548. object
  549. call_proc(sym,link,argd,ll)
  550. object sym;
  551. int argd, *link;
  552. va_list ll;
  553. {object fun;
  554.  int nargs;
  555.  check_type_symbol(&sym);
  556.  fun=sym->s.s_gfdef;
  557.  if (fun && (type_of(fun)==t_sfun
  558.          || type_of(fun)==t_gfun
  559.          || type_of(fun)== t_vfun)
  560.          && Rset) /* the && Rset is to allow tracing */
  561.    {object_func fn;
  562.     fn =  (object_func) fun->sfn.sfn_self;
  563.     if (type_of(fun)==t_vfun)
  564.       { /* argd=VFUN_NARGS; */ /*remove this! */
  565.     nargs=SFUN_NARGS(argd);
  566.     if (nargs < fun->vfn.vfn_minargs || nargs > fun->vfn.vfn_maxargs
  567.         || (argd & (SFUN_ARG_TYPE_MASK | SFUN_RETURN_MASK)))
  568.      goto WRONG_ARGS;
  569.     if ((VFUN_NARG_BIT & argd) == 0)
  570.      /* don't link */
  571.      { 
  572.        VFUN_NARGS = nargs;
  573.        goto   AFTER_LINK;
  574.      }
  575.       }
  576.     else /* t_gfun,t_sfun */
  577.       { nargs= SFUN_NARGS(argd);
  578.     if ((argd & (~VFUN_NARG_BIT)) != fun->sfn.sfn_argd) 
  579.     WRONG_ARGS:    
  580.       FEerror("Arg or result mismatch in call to  ~s",1,sym);
  581.       }
  582.    
  583.     (void) vpush_extend((int) link,Vlink_array->s.s_dbind);
  584.     (void) vpush_extend((int) *link,Vlink_array->s.s_dbind);     
  585.     *link = (int)fn;
  586.   AFTER_LINK:    
  587.  
  588.     if (nargs < 10) 
  589.     /* code below presumes sizeof(int) == sizeof(object)
  590.        Should probably not bother special casing the < 10 args
  591.      */
  592.       {object x0,x1,x2,x3,x4,x5,x6,x7,x8,x9;    
  593.        if (nargs-- > 0)
  594.      x0=va_arg(ll,object);
  595.        else
  596.      {return((*fn)());}
  597.        if (nargs-- > 0)
  598.      x1=va_arg(ll,object);
  599.        else
  600.      { return((*fn)(x0));}
  601.        if (nargs-- > 0)
  602.      x2=va_arg(ll,object);
  603.        else
  604.      {return((*fn)(x0,x1));}
  605.        if (nargs-- > 0)  x3=va_arg(ll,object);
  606.        else
  607.      return((*fn)(x0,x1,x2));
  608.        if (nargs-- > 0)  x4=va_arg(ll,object);
  609.        else
  610.      return((*fn)(x0,x1,x2,x3));
  611.        if (nargs-- > 0)  x5=va_arg(ll,object);
  612.        else
  613.      return((*fn)(x0,x1,x2,x3,x4));
  614.        if (nargs-- > 0)  x6=va_arg(ll,object);
  615.        else
  616.      return((*fn)(x0,x1,x2,x3,x4,x5));
  617.        if (nargs-- > 0)  x7=va_arg(ll,object);
  618.        else
  619.      return((*fn)(x0,x1,x2,x3,x4,x5,x6));
  620.        if (nargs-- > 0)  x8=va_arg(ll,object);
  621.        else
  622.      return((*fn)(x0,x1,x2,x3,x4,x5,x6,x7));
  623.        if (nargs-- > 0)  x9=va_arg(ll,object);
  624.        else
  625.      return((*fn)(x0,x1,x2,x3,x4,x5,x6,x7,x8));
  626.        return((*fn)(x0,x1,x2,x3,x4,x5,x6,x7,x8,x9));
  627.  
  628.      }
  629.   else {object *new;
  630.     COERCE_VA_LIST(new,ll,nargs);
  631.     return(c_apply_n(fn,nargs,new));}
  632.   }
  633.  else                /* there is no cdefn property */
  634. regular_call:
  635.    { 
  636.      object fun;
  637.      register object *base;
  638.      enum ftype result_type;
  639.      /* we check they are valid functions before calling this */
  640.      if(type_of(sym)==t_symbol) fun = symbol_function(sym);
  641.      else fun = sym;
  642.      vs_base= (base =   vs_top);
  643.      if (fun == OBJNULL) FEinvalid_function(sym);
  644.      /* push the args */
  645. /*     if (type_of(fun)==t_vfun) argd=fcall.argd; */ /*remove this! */
  646.      nargs=SFUN_NARGS(argd);
  647.      result_type=SFUN_RETURN_TYPE(argd);
  648.      argd=SFUN_START_ARG_TYPES(argd);
  649.      {int i=0;
  650.       if (argd==0)
  651.     {while(i < nargs)
  652.         {vs_push(va_arg(ll,object));
  653.          i++;}}
  654.       else
  655.     {while(i < nargs)
  656.         {enum ftype typ=SFUN_NEXT_TYPE(argd);
  657.           vs_push((typ==f_object? va_arg(ll,object):
  658.                make_fixnum(va_arg(ll,int))));
  659.          i++;}}
  660.     }
  661.  
  662.      vs_check;
  663.      
  664.      funcall(fun);
  665.       vs_top=base;
  666.     /* vs_base=oldbase;
  667.       The caller won't expect us to restore these.  */
  668.      return((result_type==f_object? vs_base[0] : (object)fix(vs_base[0])));
  669.    }
  670. }
  671.  
  672.  
  673. object call_vproc(sym,link,ll)
  674. object sym;
  675. int *link;
  676. va_list ll;     
  677. {return call_proc(sym,link,VFUN_NARGS | VFUN_NARG_BIT,ll);}
  678.  
  679. object
  680. call_proc0(sym,link)
  681. object sym;
  682. int *link;
  683. {return call_proc(sym,link,0,0);}
  684.  
  685. object
  686. call_proc1(sym,link,x0)
  687.      object sym,x0;int *link;
  688.      
  689. {return (call_proc(sym,link,1,x0));}
  690.  
  691. object
  692. call_proc2(sym,link,x0,x1)
  693.      object sym,x0,x1;int *link;
  694. {return (call_proc(sym,link,2,x0,x1));}
  695.  
  696.  
  697.    
  698.  
  699. object
  700. ifuncall(sym,n,va_alist)
  701. object sym; int n;
  702. va_dcl
  703. { va_list ap;
  704.   int i;
  705.   object *old_vs_base;
  706.   object *old_vs_top;
  707.   object x;
  708.   old_vs_base = vs_base;
  709.   old_vs_top = vs_top;
  710.   vs_base = old_vs_top;
  711.   vs_top=old_vs_top+n;
  712.   vs_check;
  713.   va_start(ap);
  714.   for(i=0;i<n;i++)
  715.     old_vs_top[i]= va_arg(ap,object);
  716.   va_end(ap);
  717.   if (type_of(sym->s.s_gfdef)==t_cfun)
  718.     (*(sym->s.s_gfdef)->cf.cf_self)();
  719.   else  super_funcall(sym);
  720. /*   funcall(sym->s.s_gfdef);*/
  721.   x = vs_base[0];
  722.   vs_top = old_vs_top;
  723.   vs_base = old_vs_base;
  724.   return(x);
  725. }
  726.  
  727.  
  728. object
  729. imfuncall(sym,n,va_alist)
  730. object sym; int n;
  731. va_dcl
  732. { va_list ap;
  733.   int i;
  734.   object *old_vs_top;
  735.   old_vs_top = vs_top;
  736.   vs_base = old_vs_top;
  737.   vs_top=old_vs_top+n;
  738.   vs_check;
  739.   va_start(ap);
  740.   for(i=0;i<n;i++)
  741.     old_vs_top[i]= va_arg(ap,object);
  742.   va_end(ap);
  743.   if (type_of(sym->s.s_gfdef)==t_cfun)
  744.     (*(sym->s.s_gfdef)->cf.cf_self)();
  745.   else  super_funcall(sym);
  746. /*   funcall(sym->s.s_gfdef);*/
  747.   return(vs_base[0]);
  748. }
  749.  
  750. /* go from beg+1 below limit setting entries equal to 0 until you
  751.    come to FRESH 0's . */
  752.  
  753. #define FRESH 40
  754.  
  755. clear_stack(beg,limit)
  756. object *beg,*limit;
  757. {int i=0;
  758.  while (++beg < limit)
  759.   {if (*beg==0) i++;
  760.    if (i > FRESH) return 0;
  761.    ;*beg=0;} return 0;}
  762.  
  763. object
  764. set_mv(i,val)
  765.      int i;
  766.      object val;
  767. { if (i >= (sizeof(MVloc)/sizeof(object)))
  768.      FEerror("Bad mv index");
  769.   return(MVloc[i]=val);
  770. }
  771.  
  772. object
  773. mv_ref(i)
  774.      unsigned int i;
  775. { if (i >= (sizeof(MVloc)/sizeof(object)))
  776.      FEerror("Bad mv index");
  777.   return (MVloc[i]);
  778. }
  779.  
  780. #include "xdrfuns.c"
  781.  
  782. init_links()
  783. {    Vlink_array = (object) make_special("*LINK-ARRAY*",Cnil);
  784.     make_function("USE-FAST-LINKS", Luse_fast_links);
  785.     siLcdefn=make_si_ordinary("CDEFN");
  786.     make_si_sfun("SET-MV",set_mv, ARGTYPE2(f_fixnum,f_object) |
  787.              RESTYPE(f_object));
  788.     make_si_sfun("MV-REF",mv_ref, ARGTYPE1(f_fixnum) | RESTYPE(f_object));
  789.     init_xdrfuns();
  790.           }
  791.  
  792.